home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / srfi / srfi-35.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  10.8 KB  |  338 lines
  1. ;;; srfi-35.scm --- Conditions
  2.  
  3. ;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
  4. ;;
  5. ;; This library is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU Lesser General Public
  7. ;; License as published by the Free Software Foundation; either
  8. ;; version 2.1 of the License, or (at your option) any later version.
  9. ;;
  10. ;; This library is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;; Lesser General Public License for more details.
  14. ;;
  15. ;; You should have received a copy of the GNU Lesser General Public
  16. ;; License along with this library; if not, write to the Free Software
  17. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18.  
  19. ;;; Author: Ludovic CourtËs <ludo@gnu.org>
  20.  
  21. ;;; Commentary:
  22.  
  23. ;; This is an implementation of SRFI-35, "Conditions".  Conditions are a
  24. ;; means to convey information about exceptional conditions between parts of
  25. ;; a program.
  26.  
  27. ;;; Code:
  28.  
  29. (define-module (srfi srfi-35)
  30.   #:use-module (srfi srfi-1)
  31.   #:export (make-condition-type condition-type?
  32.             make-condition condition? condition-has-type? condition-ref
  33.             make-compound-condition extract-condition
  34.             define-condition-type condition
  35.             &condition
  36.             &message message-condition? condition-message
  37.             &serious serious-condition?
  38.             &error error?))
  39.  
  40. (cond-expand-provide (current-module) '(srfi-35))
  41.  
  42.  
  43. ;;;
  44. ;;; Condition types.
  45. ;;;
  46.  
  47. (define %condition-type-vtable
  48.   ;; The vtable of all condition types.
  49.   ;;   vtable fields: vtable, self, printer
  50.   ;;   user fields:   id, parent, all-field-names
  51.   (make-vtable-vtable "prprpr" 0
  52.               (lambda (ct port)
  53.             (if (eq? ct %condition-type-vtable)
  54.                 (display "#<condition-type-vtable>")
  55.                 (format port "#<condition-type ~a ~a>"
  56.                     (condition-type-id ct)
  57.                     (number->string (object-address ct)
  58.                             16))))))
  59.  
  60. (define (condition-type? obj)
  61.   "Return true if OBJ is a condition type."
  62.   (and (struct? obj)
  63.        (eq? (struct-vtable obj)
  64.         %condition-type-vtable)))
  65.  
  66. (define (condition-type-id ct)
  67.   (and (condition-type? ct)
  68.        (struct-ref ct 3)))
  69.  
  70. (define (condition-type-parent ct)
  71.   (and (condition-type? ct)
  72.        (struct-ref ct 4)))
  73.  
  74. (define (condition-type-all-fields ct)
  75.   (and (condition-type? ct)
  76.        (struct-ref ct 5)))
  77.  
  78.  
  79. (define (struct-layout-for-condition field-names)
  80.   ;; Return a string denoting the layout required to hold the fields listed
  81.   ;; in FIELD-NAMES.
  82.   (let loop ((field-names field-names)
  83.          (layout      '("pr")))
  84.     (if (null? field-names)
  85.     (string-concatenate/shared layout)
  86.     (loop (cdr field-names)
  87.           (cons "pr" layout)))))
  88.  
  89. (define (print-condition c port)
  90.   (format port "#<condition ~a ~a>"
  91.       (condition-type-id (condition-type c))
  92.       (number->string (object-address c) 16)))
  93.  
  94. (define (make-condition-type id parent field-names)
  95.   "Return a new condition type named ID, inheriting from PARENT, and with the
  96. fields whose names are listed in FIELD-NAMES.  FIELD-NAMES must be a list of
  97. symbols and must not contain names already used by PARENT or one of its
  98. supertypes."
  99.   (if (symbol? id)
  100.       (if (condition-type? parent)
  101.       (let ((parent-fields (condition-type-all-fields parent)))
  102.         (if (and (every symbol? field-names)
  103.              (null? (lset-intersection eq?
  104.                            field-names parent-fields)))
  105.         (let* ((all-fields (append parent-fields field-names))
  106.                (layout     (struct-layout-for-condition all-fields)))
  107.           (make-struct %condition-type-vtable 0
  108.                    (make-struct-layout layout) ;; layout
  109.                    print-condition             ;; printer
  110.                    id parent all-fields))
  111.         (error "invalid condition type field names"
  112.                field-names)))
  113.       (error "parent is not a condition type" parent))
  114.       (error "condition type identifier is not a symbol" id)))
  115.  
  116. (define (make-compound-condition-type id parents)
  117.   ;; Return a compound condition type made of the types listed in PARENTS.
  118.   ;; All fields from PARENTS are kept, even same-named ones, since they are
  119.   ;; needed by `extract-condition'.
  120.   (cond ((null? parents)
  121.          (error "`make-compound-condition-type' passed empty parent list"
  122.                 id))
  123.         ((null? (cdr parents))
  124.          (car parents))
  125.         (else
  126.          (let* ((all-fields (append-map condition-type-all-fields
  127.                                         parents))
  128.                 (layout     (struct-layout-for-condition all-fields)))
  129.            (make-struct %condition-type-vtable 0
  130.                         (make-struct-layout layout) ;; layout
  131.                         print-condition             ;; printer
  132.                         id
  133.                         parents                     ;; list of parents!
  134.                         all-fields
  135.                         all-fields)))))
  136.  
  137.  
  138. ;;;
  139. ;;; Conditions.
  140. ;;;
  141.  
  142. (define (condition? c)
  143.   "Return true if C is a condition."
  144.   (and (struct? c)
  145.        (condition-type? (struct-vtable c))))
  146.  
  147. (define (condition-type c)
  148.   (and (struct? c)
  149.        (let ((vtable (struct-vtable c)))
  150.      (if (condition-type? vtable)
  151.          vtable
  152.          #f))))
  153.  
  154. (define (condition-has-type? c type)
  155.   "Return true if condition C has type TYPE."
  156.   (if (and (condition? c) (condition-type? type))
  157.       (let loop ((ct (condition-type c)))
  158.         (or (eq? ct type)
  159.             (and ct
  160.                  (let ((parent (condition-type-parent ct)))
  161.                    (if (list? parent)
  162.                        (any loop parent) ;; compound condition
  163.                        (loop (condition-type-parent ct)))))))
  164.       (throw 'wrong-type-arg "condition-has-type?"
  165.              "Wrong type argument")))
  166.  
  167. (define (condition-ref c field-name)
  168.   "Return the value of the field named FIELD-NAME from condition C."
  169.   (if (condition? c)
  170.       (if (symbol? field-name)
  171.       (let* ((type   (condition-type c))
  172.          (fields (condition-type-all-fields type))
  173.          (index  (list-index (lambda (name)
  174.                        (eq? name field-name))
  175.                      fields)))
  176.         (if index
  177.         (struct-ref c index)
  178.         (error "invalid field name" field-name)))
  179.       (error "field name is not a symbol" field-name))
  180.       (throw 'wrong-type-arg "condition-ref"
  181.              "Wrong type argument: ~S" c)))
  182.  
  183. (define (make-condition-from-values type values)
  184.   (apply make-struct type 0 values))
  185.  
  186. (define (make-condition type . field+value)
  187.   "Return a new condition of type TYPE with fields initialized as specified
  188. by FIELD+VALUE, a sequence of field names (symbols) and values."
  189.   (if (condition-type? type)
  190.       (let* ((all-fields (condition-type-all-fields type))
  191.          (inits      (fold-right (lambda (field inits)
  192.                        (let ((v (memq field field+value)))
  193.                      (if (pair? v)
  194.                          (cons (cadr v) inits)
  195.                          (error "field not specified"
  196.                             field))))
  197.                      '()
  198.                      all-fields)))
  199.     (make-condition-from-values type inits))
  200.       (throw 'wrong-type-arg "make-condition"
  201.              "Wrong type argument: ~S" type)))
  202.  
  203. (define (make-compound-condition . conditions)
  204.   "Return a new compound condition composed of CONDITIONS."
  205.   (let* ((types  (map condition-type conditions))
  206.      (ct     (make-compound-condition-type 'compound types))
  207.      (inits  (append-map (lambda (c)
  208.                    (let ((ct (condition-type c)))
  209.                  (map (lambda (f)
  210.                     (condition-ref c f))
  211.                       (condition-type-all-fields ct))))
  212.                  conditions)))
  213.     (make-condition-from-values ct inits)))
  214.  
  215. (define (extract-condition c type)
  216.   "Return a condition of condition type TYPE with the field values specified
  217. by C."
  218.  
  219.   (define (first-field-index parents)
  220.     ;; Return the index of the first field of TYPE within C.
  221.     (let loop ((parents parents)
  222.            (index   0))
  223.       (let ((parent (car parents)))
  224.     (cond ((null? parents)
  225.            #f)
  226.           ((eq? parent type)
  227.            index)
  228.           ((pair? parent)
  229.            (or (loop parent index)
  230.            (loop (cdr parents)
  231.              (+ index
  232.                 (apply + (map condition-type-all-fields
  233.                       parent))))))
  234.           (else
  235.            (let ((shift (length (condition-type-all-fields parent))))
  236.          (loop (cdr parents)
  237.                (+ index shift))))))))
  238.  
  239.   (define (list-fields start-index field-names)
  240.     ;; Return a list of the form `(FIELD-NAME VALUE...)'.
  241.     (let loop ((index       start-index)
  242.            (field-names field-names)
  243.            (result      '()))
  244.       (if (null? field-names)
  245.       (reverse! result)
  246.       (loop (+ 1 index)
  247.         (cdr field-names)
  248.         (cons* (struct-ref c index)
  249.                (car field-names)
  250.                result)))))
  251.  
  252.   (if (and (condition? c) (condition-type? type))
  253.       (let* ((ct     (condition-type c))
  254.              (parent (condition-type-parent ct)))
  255.         (cond ((eq? type ct)
  256.                c)
  257.               ((pair? parent)
  258.                ;; C is a compound condition.
  259.                (let ((field-index (first-field-index parent)))
  260.                  ;;(format #t "field-index: ~a ~a~%" field-index
  261.                  ;;        (list-fields field-index
  262.                  ;;                     (condition-type-all-fields type)))
  263.                  (apply make-condition type
  264.                         (list-fields field-index
  265.                                      (condition-type-all-fields type)))))
  266.               (else
  267.                ;; C does not have type TYPE.
  268.                #f)))
  269.       (throw 'wrong-type-arg "extract-condition"
  270.              "Wrong type argument")))
  271.  
  272.  
  273. ;;;
  274. ;;; Syntax.
  275. ;;;
  276.  
  277. (define-macro (define-condition-type name parent pred . field-specs)
  278.   `(begin
  279.      (define ,name
  280.        (make-condition-type ',name ,parent
  281.                 ',(map car field-specs)))
  282.      (define (,pred c)
  283.        (condition-has-type? c ,name))
  284.      ,@(map (lambda (field-spec)
  285.           (let ((field-name (car field-spec))
  286.             (accessor   (cadr field-spec)))
  287.         `(define (,accessor c)
  288.            (condition-ref c ',field-name))))
  289.         field-specs)))
  290.  
  291. (define-macro (condition . type-field-bindings)
  292.   (cond ((null? type-field-bindings)
  293.      (error "`condition' syntax error" type-field-bindings))
  294.     (else
  295.      ;; the poor man's hygienic macro
  296.      (let ((mc   (gensym "mc"))
  297.            (mcct (gensym "mcct")))
  298.        `(let ((,mc   (@  (srfi srfi-35) make-condition))
  299.           (,mcct (@@ (srfi srfi-35) make-compound-condition-type)))
  300.           (,mc (,mcct 'compound (list ,@(map car type-field-bindings)))
  301.            ,@(append-map (lambda (type-field-binding)
  302.                    (append-map (lambda (field+value)
  303.                          (let ((f (car field+value))
  304.                                (v (cadr field+value)))
  305.                            `(',f ,v)))
  306.                            (cdr type-field-binding)))
  307.                  type-field-bindings)))))))
  308.  
  309.  
  310. ;;;
  311. ;;; Standard condition types.
  312. ;;;
  313.  
  314. (define &condition
  315.   ;; The root condition type.
  316.   (make-struct %condition-type-vtable 0
  317.            (make-struct-layout "")
  318.            (lambda (c port)
  319.          (display "<&condition>"))
  320.            '&condition #f '() '()))
  321.  
  322. (define-condition-type &message &condition
  323.   message-condition?
  324.   (message condition-message))
  325.  
  326. (define-condition-type &serious &condition
  327.   serious-condition?)
  328.  
  329. (define-condition-type &error &serious
  330.   error?)
  331.  
  332.  
  333. ;;; Local Variables:
  334. ;;; coding: latin-1
  335. ;;; End:
  336.  
  337. ;;; srfi-35.scm ends here
  338.